home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Pascal Super Library
/
Pascal Super Library (CW International)(1997).bin
/
SHELLS
/
SZ2
/
GSTRING.IMP
< prev
next >
Wrap
Text File
|
1992-08-31
|
37KB
|
1,033 lines
{*******************************************************************
GSTRING.IMP
*******************************************************************}
{|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
*** TEXT ***
|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||}
{===================================================================
BLANK - TRUE if blank or WhiteSpace
===================================================================}
function IsBlank ( S : string ) : boolean ;
var
x : byte ;
begin
IsBlank := FALSE ;
for x := 1 to length ( S ) do
if S [ x ] <> #32 then EXIT ;
IsBlank := TRUE ;
end ;
{===================================================================
DUP - Return string of length "Len" of char "Ch"
===================================================================}
function StrDup ( Ch : char ; len : byte ) : string ;
var
S : string ;
begin
FillChar ( S [ 1 ] , 255 , Ch ) ;
S [ 0 ] := chr ( len ) ;
StrDup := S ;
end ;
{===================================================================
CASE (to upper)
===================================================================}
function StrUpCase ( S : string ) : string ;
var
b : byte ;
begin
for b := 1 to length ( S ) do
S [ b ] := UpCase ( S [ b ] ) ;
StrUpCase := S ;
end ;
{===================================================================
CASE (to lower)
===================================================================}
function LoCase ( Ch : char ) : char ;
begin
if Ch in [ 'A'..'Z' ] then
LoCase := Chr ( Ord ( Ch ) + 32 )
else
LoCase := Ch ;
end ;
{===================================================================
CASE (to lower)
===================================================================}
function StrLoCase ( S : string ) : string ;
var
x : byte ;
begin
for x := 1 to length ( S ) do
S [ x ] := LoCase ( S [ x ] ) ;
StrLoCase := S ;
end ;
{===================================================================
CAPITALS - 1st letter only
===================================================================}
function Capitalize ( S : string ) : string ;
var
x : byte ;
begin
Capitalize := S ;
for x := 1 to length ( S ) do
if S [ x ] in [ 'a'..'z' , 'A'..'Z' ] then
begin
S [ x ] := UpCase ( S [ x ] ) ;
Capitalize := S ;
EXIT ;
end ;
end ;
{===================================================================
CAPITAL - all words (after each non-alpha)
===================================================================}
function InitialCaps ( S : string ) : string ;
var
DoCap : boolean ;
x : byte ;
begin
DoCap := S [ 1 ] in [ 'a'..'z' , 'A'..'Z' ] ;
for x := 1 to length ( S ) do
begin
if DoCap then
begin
S [ x ] := UpCase ( S [ x ] ) ;
DoCap := FALSE ;
end ;
if not ( S [ x ] in [ 'a'..'z' , 'A'..'Z' ] ) then
DoCap := TRUE ;
end ;
InitialCaps := S ;
end ;
{===================================================================
PAD - increase to length "Len" with leading chars
===================================================================}
function PadLeft ( S : string ; Ch : char ; Len : byte ) : string ;
begin
while length ( S ) < len do
S := Ch + S ;
PadLeft := S ;
end ;
{===================================================================
PAD - increase to length "Len" with trailing chars
===================================================================}
function PadRight ( S : string ; Ch : char ; Len : byte ) : string ;
begin
while length ( S ) < len do
S := S + Ch ;
PadRight := S ;
end ;
{===================================================================
PUT - add leading chars
===================================================================}
function PutLeft ( S : string ; Ch : char ; Count : byte ) : string ;
begin
PutLeft := StrDup ( Ch , Count ) + S ;
end ;
{===================================================================
PUT - add trailing chars
===================================================================}
function PutRight ( S : string ; Ch : char ; Count : byte ) : string ;
begin
PutRight := S + StrDup ( Ch , Count ) ;
end ;
{===================================================================
COPY - Start to Stop, versus Start & Quantity
NOTE: Returns blank on invalid index
===================================================================}
function CopyPos ( S : string ; Start , Stop : integer ) : string ;
begin
CopyPos := '' ;
if Stop >= Start then
if Start > 0 then
CopyPos := Copy ( S ,
Start ,
Stop - Start + 1 ) ;
end ;
{===================================================================
DELETE - Start to Stop, versus Start & Quantity
NOTE: Return original on invalid index
===================================================================}
function DeletePos ( S : string ; Start , Stop : integer ) : string ;
begin
if Stop >= Start then
if Start > 0 then
delete ( S , Start , Stop - Start + 1 ) ;
DeletePos := S ;
end ;
{===================================================================
TRUNCATE - Delete from Index to end of string
===================================================================}
function Truncate ( Source : string ; Index : byte ) : string ;
begin
Truncate := DeletePos ( Source ,
Index ,
length ( Source ) ) ;
end ;
{===================================================================
MATCH - return position, ignore case
===================================================================}
function Match ( SubStr , Target : string ) : integer ;
begin
if length ( SubStr ) > 0 then
Match := pos ( StrUpCase ( SubStr ) ,
StrUpCase ( Target ) )
else
Match := 0 ;
end ;
{===================================================================
EXIST - if "SubStr" in "Target"; ignores case
===================================================================}
function StrExist ( SubStr , Target : string ) : boolean ;
begin
StrExist := Match ( SubStr , Target ) > 0 ;
end ;
{===================================================================
COUNT - number of occurances
===================================================================}
function StrCount ( SubStr , S : string ) : integer ;
var
x : integer ;
Index : integer ;
begin
x := 0 ;
while TRUE do
begin
Index := Match ( SubStr , S ) ;
if Index = 0 then
begin
StrCount := x ;
EXIT ;
end ;
inc ( x ) ;
delete ( S , Index , Length ( SubStr ) ) ;
end ;
end ;
{|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
TRIM
|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||}
{===================================================================
LEAD
===================================================================}
function TrimLeft ( Source , SubStr : string ) : string ;
begin
SubStr := StrUpCase ( SubStr ) ;
while pos ( SubStr , StrUpCase ( Source ) ) = 1 do
delete ( Source , 1 , length ( SubStr ) ) ;
TrimLeft := Source ;
end ;
{===================================================================
TRAIL - ignores case
===================================================================}
function TrimRight ( Source , SubStr : string ) : string ;
var
Index : integer ;
Temp : string ;
begin
SubStr := StrUpCase ( SubStr ) ;
while TRUE do
begin
Index := length ( Source ) - length ( SubStr ) + 1 ;
temp := CopyPos ( Source ,
Index ,
length ( Source ) );
if StrUpCase ( Temp ) <> SubStr then
begin
TrimRight := Source ;
EXIT ;
end ;
Source := DeletePos ( Source ,
Index ,
length ( Source ) ) ;
end ;
end ;
{===================================================================
LEAD & TRAIL
===================================================================}
function Trim ( Source , SubStr : string ) : string ;
begin
Source := TrimLeft ( Source , SubStr ) ;
Source := TrimRight ( Source , SubStr ) ;
Trim := Source ;
end ;
{===================================================================
PREFIX - remove first occurance of "SubStr"
===================================================================}
function TrimPrefix ( Source , SubStr : string ) : string ;
begin
if Match ( SubStr , Source ) = 1 then
delete ( Source , 1 , length ( SubStr ) ) ;
TrimPrefix := Source ;
end ;
{===================================================================
PLUCK - return word by index. Guaranteed not to have whitespace.
===================================================================}
function Pluck ( S : string ; Index : byte ) : string ;
var
count : byte ;
Last : byte ;
temp : string ;
begin
Pluck := '' ;
count := 0 ;
temp := '' ;
S := Trim ( S , #32 ) ; { lead/trail whitespace }
while TRUE do
begin
if count = Index then
begin
Pluck := temp ;
EXIT ;
end ;
if S = '' then EXIT ;
if pos ( #32 , S ) = 0 then
Last := length ( S )
else
Last := pos ( #32 , S ) - 1 ;
temp := copy ( S , 1 , Last ) ;
delete ( S , 1 , Last ) ;
S := TrimLeft ( S , #32 ) ; { delete whitespace }
inc ( count ) ;
end ;
end ;
{===================================================================
WORD COUNT - SubStrings separated by whitespace
===================================================================}
function WordCount ( S : string ) : byte ;
var
count : byte ;
begin
count := 0 ;
S := Trim ( S , #32 ) ; { delete whitespace }
while TRUE do
begin
if S = '' then
begin
WordCount := count ;
EXIT ;
end ;
if pos ( #32 , S ) = 0 then
S := ''
else
delete ( S , 1 , pos ( #32 , S ) - 1 ) ;
S := TrimLeft ( S , #32 ) ; { delete whitespace }
inc ( count ) ;
end ;
end ;
{===================================================================
POS - Index of "Substr" in "Source", from "Start"; ignores case
===================================================================}
function PosNext ( Substr , Source : string ; Start : byte ) : byte ;
var
found : boolean ;
Index ,
j ,
Limit : byte ;
begin
PosNext := 0 ;
if Source = '' then EXIT ;
if length ( SubStr ) = 0 then EXIT ;
if length ( Source ) < length ( SubStr ) then EXIT ;
Source := StrUpCase ( Source ) ;
SubStr := StrUpCase ( SubStr ) ;
Limit := length ( Source ) -
length ( SubStr ) +
1 ;
if Start < 1 then
Start := 1 ;
for Index := Start to Limit do
begin
found := TRUE ;
J := 0 ;
Repeat
inc ( j ) ;
if Source [ Index + j - 1 ] <>
SubStr [ j ] then
found := FALSE ;
Until ( not found ) or
( j >= length ( SubStr ) ) ;
if found then
begin
PosNext := Index ;
EXIT ;
end ;
end ;
end ;
{===================================================================
EXTRACT - From "SubStr" to whitespace or end; ignores case
Source = 'hello kbNoKey there'
SubStr = 'kb'
Extract = 'kbNoKey'
Source = 'hello there'
===================================================================}
function Extract ( SubStr : string ; VAR Source : string ) : string ;
var
Start : integer ;
Stop : integer ;
begin
Extract := '' ;
SubStr := Trim ( SubStr , #32 ) ;
if length ( SubStr ) = 0 then EXIT ;
Start := Match ( SubStr , Source ) ;
if Start <> 1 then
begin
SubStr := #32 + SubStr ;
Start := Match ( SubStr , Source ) ;
end ;
if Start = 0 then EXIT ;
Stop := PosNext ( #32 , Source , Start + 1 ) - 1 ;
if Stop < 1 then
Stop := length ( Source ) ;
SubStr := CopyPos ( Source ,
Start ,
Stop ) ;
Extract := Trim ( SubStr , #32 ) ;
Source := DeletePos ( Source , Start , Stop ) ;
end ;
{===================================================================
REPLACE - All occurances of Original with Replacement; ignores case
===================================================================}
function Replace ( Source , Original , Replacement : string ) : string ;
var
Index ,
L ,
L2 : byte ;
begin
Index := PosNext ( Original , Source , 1 ) ;
L := length ( Original ) ;
L2 := length ( Replacement ) ;
while Index > 0 do
begin
Delete ( Source , Index , L ) ; { Cut }
Insert ( Replacement , Source ,Index ) ; { Paste }
Index := Index +
1 -
L +
L2 ;
Index := PosNext ( Original , Source , Index ) ;
end ;
Replace := Source ;
end ;
{===================================================================
REPLACECHAR - each CHAR in "CharSet" with "Replacement" string
Note - case sensitive
===================================================================}
function ReplaceChar ( S , CharSet , Replacement : string ) : string ;
var
i ,
L : byte ;
c : char ;
begin
i := 1 ;
L := length ( Replacement ) ;
while i <= length ( S ) do
begin
C := S [ i ] ;
if pos ( C , CharSet ) > 0 then
begin
delete ( S , i , 1 ) ;
insert ( Replacement , S , i ) ;
inc ( i , L ) ;
end
else
inc ( i ) ;
end ;
ReplaceChar := S ;
end ;
{===================================================================
FILL - replace WhiteSpace with "FillChar" between SearchChars
===================================================================}
function FillBetween ( S : string ; SearchCh , FillCh : char ) : string ;
var
x : byte ;
Found : boolean ;
begin
Found := FALSE ;
for x := 1 to length ( S ) do
begin
if Found then
begin
if S [ x ] = SearchCh then
Found := FALSE
else
if S [ x ] = #32 then
S [ x ] := FillCh ;
end
else
if S [ x ] = SearchCh then
Found := TRUE ;
end ;
FillBetween := S ;
end ;
{===================================================================
COUNT CHAR - number of occurances of "Ch" in "S"
===================================================================}
function CountCh ( Ch : char ; S : string ) : byte ;
var
count : byte ;
begin
count := 0 ;
while pos ( Ch , S ) > 0 do
begin
inc ( count ) ;
delete ( S , pos ( Ch , S ) , 1 ) ;
end ;
CountCh := count ;
end ;
{===================================================================
WIDE SPACE - Left/Right Justify, Center & Fill-Between by replacing
"^W" chars with spaces until desired width is reached.
^W+"Hello" --> " Hello"
"Hello"+^W --> "Hello "
^W+"Hello"+^W --> " Hello "
"Hi"+^W+"There" --> "Hi There"
===================================================================}
function WideSpace ( S : string ; Code : Char ; NewWidth : byte ) : string ;
var
Wcount ,
index : byte ;
{-------------------------------------------------------------------
-------------------------------------------------------------------}
procedure Run ;
begin
while TRUE do
begin
if length ( S ) >= NewWidth then EXIT ;
index := 1 ;
while index <= length ( S ) do
begin
if length ( S ) >= NewWidth then EXIT ;
if S [ index ] = Code then
begin
insert ( #32 , S , index ) ;
inc ( index ) ;
end ;
inc ( index ) ;
end ;
end ;
end ;
{- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -}
begin
WideSpace := S ;
Wcount := CountCh ( Code , S ) ;
if Wcount = 0 then EXIT ;
NewWidth := NewWidth + Wcount ;
Run ;
while pos ( Code , S ) > 0 do
delete ( S , pos ( Code , S ) , 1 ) ;
WideSpace := S ;
end ;
{===================================================================
IBM Graphics/Line-Draw to ASCII
===================================================================}
procedure ConvertLineDraw ( VAR Ch : char ) ;
begin
if Ord ( Ch ) and $0080 = 0 then EXIT ;
case Ch of
{-------------------------------------------------------------------
CORNERS
-------------------------------------------------------------------}
'⌐' , '¬' , '╖' , '╕' , '╗', '╝' , '╜' , '╛' , '┐', '└' , '╚' , '╔' ,
'╙' , '╘' , '╒' , '╓' , '┘' , '┌' : Ch := '+' ;
{-------------------------------------------------------------------
INTERSECTIONS
-------------------------------------------------------------------}
'┴' , '┬' , '├' , '┼' , '╞' , '╟' , '╩' , '╦' , '╠' , '╬' , '╧' ,
'╨' , '╤' , '╥' , '╫' , '╪' : Ch := '#' ;
{-------------------------------------------------------------------
VERTICAL
-------------------------------------------------------------------}
'│' , '║' : Ch := '|' ;
{-------------------------------------------------------------------
HORIZONTAL
-------------------------------------------------------------------}
'─' , '═' : Ch := '-' ;
{-------------------------------------------------------------------
BLOCK
-------------------------------------------------------------------}
'░' , '▒' , '▓' , '█' , '▄' , '▌' ,'▐' , '▀' , '■' : Ch := '*' ;
else
Ch := #32 ;
end ;
end ;
{|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
*** PARAM, SWITCHES & FILENAMES ***
|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||}
{===================================================================
Everything from DOS command-line in upper case
===================================================================}
function CommandLineString : string ;
var
S : string ;
x : byte ;
begin
S := ParamStr ( 1 ) ;
for x := 2 to ParamCount do
S := S + #32 + ParamStr ( x ) ;
CommandLineString := StrUpCase ( S ) ;
end ;
{===================================================================
PARAM - Just params; ie: C:>prg "filespec ok /a/b/c" --> "FILESPEC OK"
===================================================================}
function ParameterString : string ;
begin
ParameterString := DeletePos ( CommandLineString ,
pos ( '/' , CommandLineString ) ,
length ( CommandLineString ) ) ;
end ;
{===================================================================
SWITCH - return switches separated by whitespace
ie: C:>prg "filespec ok /a/b/c" --> "/A /B /C"
===================================================================}
function SwitchString : string ;
var
S : string ;
begin
S := CopyPos ( CommandLineString ,
pos ( '/' , CommandLineString ) ,
length ( CommandLineString ) ) ;
S := Replace ( S , '/' , ' /' ) ;
SwitchString := S ;
end ;
{===================================================================
SWITCH - Return TRUE if "/a" or "a" in C:>prg "filespec ok /a/b/c"
===================================================================}
function IsSwitch ( S : string ) : boolean ;
var
Switches : string ;
x : byte ;
begin
IsSwitch := TRUE ;
S := StrUpCase ( Replace ( S , '/' , '' ) ) ;
Switches := StrUpCase ( Replace ( SwitchString ,
'/' ,
#32 ) ) ;
for x := 1 to WordCount ( Switches ) do
if S = Pluck ( Switches , x ) then EXIT ;
IsSwitch := FALSE ;
end ;
{===================================================================
PARAM - Return TRUE if "OK" or "ok" in C:>prg "filespec ok /a/b/c"
===================================================================}
function IsParam ( S : string ) : boolean ;
var
Params : string ;
x : byte ;
begin
IsParam := TRUE ;
Params := StrUpCase ( Replace ( ParameterString ,
'/' ,
#32 ) ) ;
for x := 1 to WordCount ( Params ) do
if S = Pluck ( Params , x ) then EXIT ;
IsParam := FALSE ;
end ;
{|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
NAME
|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||}
{===================================================================
DIR - replace directory. Returns fully-qualified FileSpec.
===================================================================}
function ReplaceDir ( FileSpec , Dir : string ) : string ;
var
D : DirStr ;
N : NameStr ;
E : ExtStr ;
begin
ReplaceDir := '' ;
FileSpec := FExpand ( FileSpec ) ;
FSplit ( FileSpec , D , N , E ) ;
if pos ( '.' , E ) = 0 then
E := '.' + E ;
if Dir [ length ( Dir ) ] <> '\' then
Dir := Dir + '\' ;
ReplaceDir := Dir + N + E ;
end ;
{===================================================================
NAME - replace just name; wildcard if blank
===================================================================}
function ReplaceName ( FileSpec , Name : string ) : string ;
var
D : DirStr ;
N : NameStr ;
E : ExtStr ;
begin
ReplaceName := '' ;
FSplit ( FileSpec , D , N , E ) ;
if N = '' then
N := '*' ;
if pos ( '.' , E ) = 0 then
E := '.' + E ;
ReplaceName := D + Name + E ;
end ;
{===================================================================
EXTENSION - replace if blank or Forced
===================================================================}
function ReplaceExt ( FileSpec , Ext : string ; Force : boolean ) : string ;
var
D : DirStr ;
N : NameStr ;
E : ExtStr ;
begin
ReplaceExt := '' ;
FileSpec := FExpand ( FileSpec ) ;
FSplit ( FileSpec , D , N , E ) ;
if N = '' then EXIT ; { blank! }
if Force or ( E = '' ) then
begin
if Ext <> '' then
if pos ( '.' , Ext ) = 0 then
Ext := '.' + Ext ;
ReplaceExt := D + N + Ext ;
end
else
ReplaceExt := FileSpec ;
end ;
{===================================================================
DIRECTORY - just the drive & directory.
===================================================================}
function DriveDir ( FileSpec : string ) : string ;
var
D : DirStr ;
N : NameStr ;
E : ExtStr ;
begin
FileSpec := FExpand ( FileSpec ) ;
FSplit ( FileSpec , D , N , E ) ;
DriveDir := D ;
end ;
{===================================================================
NAME
===================================================================}
function NameOnly ( FileSpec : string ) : string ;
var
D : DirStr ;
N : NameStr ;
E : ExtStr ;
begin
FileSpec := FExpand ( FileSpec ) ;
FSplit ( FileSpec , D , N , E ) ;
NameOnly := N ;
end ;
{===================================================================
EXTENSION
===================================================================}
function ExtOnly ( FileSpec : string ) : string ;
var
D : DirStr ;
N : NameStr ;
E : ExtStr ;
begin
FileSpec := FExpand ( FileSpec ) ;
FSplit ( FileSpec , D , N , E ) ;
ExtOnly := E ;
end ;
{===================================================================
NAME & EXTENSION
===================================================================}
function NameExt ( FileSpec : string ) : string ;
var
D : DirStr ;
N : NameStr ;
E : ExtStr ;
begin
FileSpec := FExpand ( FileSpec ) ;
FSplit ( FileSpec , D , N , E ) ;
NameExt := N + E ;
end ;
{===================================================================
DRIVE DIR - Uses FExpand to determine current directory
===================================================================}
function DirOfDrive ( B : byte ) : string ;
begin
if B > 26 then
B := 0 ;
if B = 0 then
DirOfDrive := FExpand ( '' )
else
DirOfDrive := FExpand ( Chr ( B + 64 ) + ':' ) ;
end ;
{===================================================================
CALC - find "FileName" in "Path" or "GetEnv('PATH')"
===================================================================}
function CalcName ( FileName , Path : PathStr ) : PathStr ;
var
Dir : DirStr ;
Name : NameStr ;
Ext : ExtStr ;
begin
CalcName := '' ;
FileName := FExpand ( FileName ) ;
{- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
DIR - In current or given
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -}
if FileExist ( FileName ) then
begin
CalcName := FileName ;
EXIT ;
end ;
{- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
DIR - On specified "Path"
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -}
FSplit ( FileName , Dir , Name , Ext ) ;
FileName := Name + Ext ;
FileName := FSearch ( FileName , Path ) ;
if FileName <> '' then
begin
CalcName := FExpand ( FileName ) ;
EXIT ;
end ;
{- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
DIR - Environment "PATH"
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -}
FileName := Name + Ext ;
FileName := FSearch ( FileName , GetEnv ( 'PATH' ) ) ;
if FileName <> '' then
begin
CalcName := FExpand ( FileName ) ;
EXIT ;
end ;
end ;
{|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
FILE
|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||}
{===================================================================
FILE EXIST
===================================================================}
function FileExist ( Path : string ) : boolean ;
var
SR : SearchRec ;
begin
FileExist := FALSE ; { set }
if Path = '' then EXIT ; { NUL not valid }
if pos ( '?' , Path ) > 0 then EXIT ; { wildcard not valid }
if pos ( '*' , Path ) > 0 then EXIT ; { wildcard not valid }
FindFirst ( Path , 0 , SR ) ; { ask DOS }
FileExist := DosError = 0 ; { result }
end ;
{===================================================================
EXISTDIR - Return TRUE if the directory exists
===================================================================}
function DirExist ( DirName : string ) : boolean ;
var
OldDosError : integer ;
SR : SearchRec ;
begin
DirExist := FALSE ;
if pos ( '?' , DirName ) > 0 then EXIT ;
if pos ( '*' , DirName ) > 0 then EXIT ;
OldDosError := DosError ;
if DirName [ length ( DirName ) ] <> '\' then
DirName := DirName + '\' ;
DirName := FExpand ( DirName ) ;
FindFirst ( DirName + '*.*' , AnyFile , SR ) ;
DirExist := ( DosError = 0 ) and
(
( SR.Attr and Directory <> 0 ) or
( length ( DirName ) = 3 ) { root }
) ;
DosError := OldDosError ;
end ;
{===================================================================
ERASE
===================================================================}
function FileErase ( S : string ) : boolean ;
var
F : File ;
begin
{$I-}
Assign ( F , S ) ;
Erase ( F ) ;
{$I+}
FileErase := IOresult = 0 ;
end ;
{===================================================================
RENAME
===================================================================}
function FileRename ( OldName , NewName : string ) : boolean ;
var
Ftemp : File ;
begin
SYSTEM.Assign ( Ftemp , OldName ) ;
{$I-}
SYSTEM.Rename ( Ftemp , NewName ) ;
{$I+}
FileRename := IOresult = 0 ;
end ;
{===================================================================
EXIST: Match case sensitive KeyString in *.REZ file.
===================================================================}
function RezExist ( KeyString , FileName : string ) : boolean ;
var
RezFile : PResourceFile ;
RezStream : PStream ;
i : integer ;
begin
RezExist := FALSE ; { assume no }
if not FileExist ( FileName ) then EXIT ; { no file }
RezStream := New ( PDosStream ,
Init ( FileName ,
stOpen ) ) ; { instance }
RezFile := New ( PResourceFile ) ; { init }
RezFile^.Init ( RezStream ) ; { init }
if RezStream^.Status <> stOK then EXIT ; { problem! }
with RezFile^ do
for i := 0 to Count - 1 do
begin
if KeyString = KeyAt ( i ) then
begin
RezExist := TRUE ; { gotcha }
Dispose ( RezFile , Done ) ; { dumps "RezStream" too }
EXIT ; { done }
end ;
end ;
Dispose ( RezFile , Done ) ; { dumps "RezStream" too }
end ;
{===================================================================
GET NAME - return name within width; remove DRIVE:\DIR if same as
current dir.
filename.ext C:\..\filename.ext D:\filename.ext
123456789012 123456789012345678 12345678901234
12 18 15
===================================================================}
function GetName ( S : PathStr ; MaxSize : byte ) : string ;
var
Dir : DirStr ;
Name : NameStr ;
Ext : ExtStr ;
Current : DirStr ;
begin
S := FExpand ( S ) ;
FSplit ( S , Dir , Name , Ext ) ;
Current := FExpand ( '' ) ;
if Dir = Current then
begin
GetName := Name + Ext ; { current dir }
EXIT
end ;
if Dir [ 1 ] = Current [ 1 ] then
delete ( Dir , 1 , 2 ) ; { dump "x:" }
if length ( Dir + Name + Ext ) > MaxSize then
if length ( Dir ) > 3 then
Dir := '\..\' ;
S := Dir + Name + Ext ;
while length ( S ) > MaxSize do { failsafe }
delete ( S , 1 , 1 ) ;
GetName := S ;
end ;
